;;;;;; environment.scm - Compile Environment module.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 16 Jun 2009

#lang scheme

(provide
 make-environment
 environment?
 environment-bindings
 enclosing-environment
 divert
 bind
 bind!
 extend
 lookup
 lookup*
 ident?
 free?)

(define (make-environment [enclosing-env #f])
  (list 'environment (make-hash) enclosing-env))

(define (environment? env)
  (and (list? env)
       (= 3 (length env))
       (eq? 'environment (car env))
       (hash? (environment-bindings env))))

(define (environment-bindings env) (second env))
(define (enclosing-environment env) (third env))

(define (bind! var val env)
  (hash-set! (environment-bindings env) var val))

(define (bind var val env)
  (extend (list var) (list val) env))

(define (extend vars vals base-env)
  (if (= (length vars) (length vals))
      (let ((env (make-environment base-env)))
        (for-each 
         (lambda (var val) 
           (bind! var val env)) 
         vars vals)
        env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (lookup var env)
  (if (environment? env)
      (let ((bin (environment-bindings env))
            (enc (enclosing-environment env)))
        (hash-ref bin var (lambda () (lookup var enc))))
      #f))

(define (lookup* var env)
  (let loop ((env env) (vals '()))
    (if (environment? env)
        (let ((bin (environment-bindings env))
              (enc (enclosing-environment env)))
          (let ((val (hash-ref bin var #f)))
            (if val
                (loop enc (cons val vals))
                (loop enc vals))))
        (reverse vals))))

(define (divert env1 env2)
  (let ((env (make-environment env1)))
    (hash-for-each (environment-bindings env1)
                   (lambda (var val) (bind! var val env)))
    env))
  
(define (ident? var env) (equal? var (lookup var env)))
(define (free? var env) (not (lookup var env)))
